home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
FishMarket 1.0
/
FishMarket v1.0.iso
/
fishies
/
376-400
/
disk_386
/
xlispstat
/
src1.lzh
/
XLisp
/
xldmem.c
< prev
next >
Wrap
C/C++ Source or Header
|
1990-10-04
|
17KB
|
795 lines
/* xldmem - xlisp dynamic memory management routines */
/* Copyright (c) 1989, by David Michael Betz. */
/* You may give out copies of this software; for conditions see the file */
/* COPYING included with this distribution. */
#include <string.h>
#include <stdlib.h>
#include "xlisp.h"
#include "osdef.h"
#ifdef ANSI
#include "xlproto.h"
#include "Stproto.h"
#include "osproto.h"
#else
#include "xlfun.h"
#include "Stfun.h"
#include "osfun.h"
#endif ANSI
#include "xlvar.h"
/* forward declarations */
#ifdef ANSI
unsigned char *stralloc(int);
void findmem(void),mark(LVAL),sweep(void),stats(void);
int addseg(void);
char *IViewNewAData(int,int,long *,int);
LVAL newnode(int);
#else
unsigned char *stralloc();
void findmem(),mark(),sweep(),stats();
int addseg();
char *IViewNewAData();
LVAL newnode();
#endif
/* node flags */
#define MARK 1
#define LEFT 2
/* macro to compute the size of a segment */
#define segsize(n) (sizeof(SEGMENT)+((n)-1)*sizeof(struct node))
/* variables local to xldmem.c and xlimage.c */
SEGMENT *segs,*lastseg,*fixseg,*charseg;
int anodes,nsegs,gccalls;
long nnodes,nfree,total;
LVAL fnodes;
/* cons - construct a new cons node */
LVAL cons(x,y)
LVAL x,y;
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
xlstkcheck(2);
xlprotect(x);
xlprotect(y);
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
xlpop();
xlpop();
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
--nfree;
/* initialize the new node */
nnode->n_type = CONS;
rplaca(nnode,x);
rplacd(nnode,y);
/* return the new node */
return (nnode);
}
/* cvstring - convert a string to a string node */
LVAL cvstring(str)
char *str;
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = strlen(str) + 1;
val->n_string = stralloc(getslength(val));
strcpy(getstring(val),str);
xlpop();
return (val);
}
/* newstring - allocate and initialize a new string */
LVAL newstring(size)
int size;
{
LVAL val;
xlsave1(val);
val = newnode(STRING);
val->n_strlen = size;
val->n_string = stralloc(getslength(val));
strcpy(getstring(val),"");
xlpop();
return (val);
}
/* cvsymbol - convert a string to a symbol */
LVAL cvsymbol(pname)
char *pname;
{
LVAL val;
xlsave1(val);
val = newvector(SYMSIZE);
val->n_type = SYMBOL;
setvalue(val,s_unbound);
setfunction(val,s_unbound);
setpname(val,cvstring(pname));
setconstant(val, FALSE); /* L. Tierney */
xlpop();
return (val);
}
/* cvsubr - convert a function to a subr or fsubr */
LVAL cvsubr(fcn,type,offset)
LVAL (*fcn)(); int type,offset;
{
LVAL val;
val = newnode(type);
val->n_subr = fcn;
val->n_offset = offset;
return (val);
}
/* cvfile - convert a file pointer to a stream */
LVAL cvfile(fp)
FILE *fp;
{
LVAL val;
val = newnode(STREAM);
setfile(val,fp);
setsavech(val,'\0');
return (val);
}
/* cvfixnum - convert an integer to a fixnum node */
LVAL cvfixnum(n)
FIXTYPE n;
{
LVAL val;
if (n >= SFIXMIN && n <= SFIXMAX)
return (&fixseg->sg_nodes[(int)n-SFIXMIN]);
val = newnode(FIXNUM);
val->n_fixnum = n;
return (val);
}
/* cvflonum - convert a floating point number to a flonum node */
LVAL cvflonum(n)
FLOTYPE n;
{
LVAL val;
val = newnode(FLONUM);
val->n_flonum = n;
return (val);
}
/* cvchar - convert an integer to a character node */
LVAL cvchar(n)
int n;
{
if (n >= CHARMIN && n <= CHARMAX)
return (&charseg->sg_nodes[n-CHARMIN]);
xlerror("character code out of range",cvfixnum((FIXTYPE)n));
}
/* newustream - create a new unnamed stream */
LVAL newustream()
{
LVAL val;
val = newnode(USTREAM);
sethead(val,NIL);
settail(val,NIL);
return (val);
}
/* newobject - allocate and initialize a new object */
LVAL newobject(cls,size)
LVAL cls; int size;
{
LVAL val;
val = newvector(size+1);
val->n_type = OBJECT;
setelement(val,0,cls);
return (val);
}
/* newclosure - allocate and initialize a new closure */
LVAL newclosure(name,type,env,fenv)
LVAL name,type,env,fenv;
{
LVAL val;
val = newvector(CLOSIZE);
val->n_type = CLOSURE;
setname(val,name);
settype(val,type);
setenv(val,env);
setfenv(val,fenv);
return (val);
}
/* newstruct - allocate and initialize a new structure node */
LVAL newstruct(type,size)
LVAL type; int size;
{
LVAL val;
val = newvector(size+1);
val->n_type = STRUCT;
setelement(val,0,type);
return (val);
}
/* newvector - allocate and initialize a new vector node */
LVAL newvector(size)
int size;
{
LVAL vect;
int bsize;
xlsave1(vect);
vect = newnode(VECTOR);
vect->n_vsize = 0;
if (bsize = size * sizeof(LVAL)) {
if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL) {
findmem();
if ((vect->n_vdata = (LVAL *)calloc(1,bsize)) == NULL)
xlfail("insufficient vector space");
}
vect->n_vsize = size;
total += (long) bsize;
}
xlpop();
return (vect);
}
#ifndef XLISP_ONLY
/*** Added for internal allocated storage - L. Tierney ***/
/*#include "stmem.h" moved above JKL */
static char *IViewNewAData(n, m, size, reloc)
int n, m, reloc;
long *size;
{
char *addr;
addr = (reloc) ? (char *)StRCalloc(n, m): StCalloc(n, m);/* casts added JKL */
*size = (reloc) ? StRSize((StReallocData)addr) : ((long) m) * ((long) n);
return(addr);
}
/* newadata(n, m, reloc) - convert a string to a string node */
LVAL newadata(n, m, reloc)
int n, m, reloc;
{
LVAL val;
long size;
xlsave1(val);
val = newnode(ALLOCATED_DATA);
val->n_adreloc = reloc;
if ((val->n_adaddr = IViewNewAData(n, m, &size, reloc)) == NULL) {
gc();
if ((val->n_adaddr = IViewNewAData(n, m, &size, reloc)) == NULL)
xlfail("insufficient memory");
}
val->n_adsize = size;
total += size;
xlpop();
return (val);
}
void reallocaddata(val, n, m)
LVAL val;
int n, m;
{
char *addr;
if (! adatap(val) || ! getadreloc(val)) xlfail("not relocatable");
addr = (char *)StRRealloc((StReallocData)getadaddr(val), n, m);/* cast added JKL */
/* if (addr == NULL) xlfail("allocation failed"); no longer necessary JKL */
val->n_adaddr = addr;
total -= getadsize(val);
val->n_adsize = (int)StRSize((StReallocData)addr);/* casts added JKL */
total += getadsize(val);
}
void freeadata(val)
LVAL val;
{
if (! adatap(val)) xlfail("not a data object");
if (getadreloc(val)) StRFree((StReallocData)getadaddr(val));/* cast added JKL */
else StFree(getadaddr(val));
val->n_adaddr = NULL;
total -= getadsize(val);
val->n_adsize = 0;
}
/*** Added for internal allocated storage - L. Tierney ***/
#endif /* XLISP_ONLY */
/* newnode - allocate a new node */
LOCAL LVAL newnode(type)
int type;
{
LVAL nnode;
/* get a free node */
if ((nnode = fnodes) == NIL) {
findmem();
if ((nnode = fnodes) == NIL)
xlabort("insufficient node space");
}
/* unlink the node from the free list */
fnodes = cdr(nnode);
nfree -= 1L;
/* initialize the new node */
nnode->n_type = type;
rplacd(nnode,NIL);
/* return the new node */
return (nnode);
}
/* stralloc - allocate memory for a string adding a byte for the terminator */
LOCAL unsigned char *stralloc(size)
int size;
{
unsigned char *sptr;
/* allocate memory for the string copy */
if ((sptr = (unsigned char *)malloc(size)) == NULL) {
gc();
if ((sptr = (unsigned char *)malloc(size)) == NULL)
xlfail("insufficient string space");
}
total += (long)size;
/* return the new string memory */
return (sptr);
}
/* findmem - find more memory by collecting then expanding */
LOCAL void findmem()
{
gc();
if (nfree < (long)anodes)
addseg();
}
/* gc - garbage collect (only called here and in xlimage.c) */
void gc()
{
register LVAL **p,*ap,tmp;
char buf[STRMAX+1];
LVAL *newfp,fun;
set_gc_cursor(TRUE); /* L. Tierney */
/* print the start of the gc message */
if (s_gcflag && getvalue(s_gcflag)) {
sprintf(buf,"[ gc: total %ld, ",nnodes);
stdputstr(buf);
}
/* mark the obarray, the argument list and the current environment */
if (obarray)
mark(obarray);
if (xlenv)
mark(xlenv);
if (xlfenv)
mark(xlfenv);
if (xldenv)
mark(xldenv);
/* mark the evaluation stack */
for (p = xlstack; p < xlstktop; ++p)
if (tmp = **p)
mark(tmp);
/* mark the argument stack */
for (ap = xlargstkbase; ap < xlsp; ++ap)
if (tmp = *ap)
mark(tmp);
/* sweep memory collecting all unmarked nodes */
sweep();
/* count the gc call */
++gccalls;
/* call the *gc-hook* if necessary */
if (s_gchook && (fun = getvalue(s_gchook))) {
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(cvfixnum((FIXTYPE)nnodes));
pusharg(cvfixnum((FIXTYPE)nfree));
xlfp = newfp;
xlapply(2);
}
/* print the end of the gc message */
if (s_gcflag && getvalue(s_gcflag)) {
sprintf(buf,"%ld free ]\n",nfree);
stdputstr(buf);
}
set_gc_cursor(FALSE); /* L. Tierney */
}
/* mark - mark all accessible nodes */
LOCAL void mark(ptr)
LVAL ptr;
{
register LVAL this,prev,tmp;
int type,i,n;
/* initialize */
prev = NIL;
this = ptr;
/* mark this list */
for (;;) {
/* descend as far as we can */
while (!(this->n_flags & MARK))
/* check cons and unnamed stream nodes */
if ((type = ntype(this)) == CONS || type == USTREAM) {
if (tmp = car(this)) {
this->n_flags |= MARK|LEFT;
rplaca(this,prev);
}
else if (tmp = cdr(this)) {
this->n_flags |= MARK;
rplacd(this,prev);
}
else { /* both sides nil */
this->n_flags |= MARK;
break;
}
prev = this; /* step down the branch */
this = tmp;
}
/* mark other node types */
else {
this->n_flags |= MARK;
switch (type) {
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
case COMPLEX: /* L. Tierney */
case DISPLACED_ARRAY:/* L. Tierney */
case STRUCT:
for (i = 0, n = getsize(this); --n >= 0; ++i)
if (tmp = getelement(this,i))
mark(tmp);
break;
}
break;
}
/* backup to a point where we can continue descending */
for (;;)
/* make sure there is a previous node */
if (prev) {
if (prev->n_flags & LEFT) { /* came from left side */
prev->n_flags &= ~LEFT;
tmp = car(prev);
rplaca(prev,this);
if (this = cdr(prev)) {
rplacd(prev,tmp);
break;
}
}
else { /* came from right side */
tmp = cdr(prev);
rplacd(prev,this);
}
this = prev; /* step back up the branch */
prev = tmp;
}
/* no previous node, must be done */
else
return;
}
}
/* sweep - sweep all unmarked nodes and add them to the free list */
LOCAL void sweep()
{
SEGMENT *seg;
LVAL p;
int n;
/* empty the free list */
fnodes = NIL;
nfree = 0L;
/* add all unmarked nodes */
for (seg = segs; seg; seg = seg->sg_next) {
if (seg == fixseg) /* don't sweep the fixnum segment */
continue;
else if (seg == charseg) /* don't sweep the character segment */
continue;
p = &seg->sg_nodes[0];
for (n = seg->sg_size; --n >= 0; ++p)
if (!(p->n_flags & MARK)) {
switch (ntype(p)) {
case STRING:
if (getstring(p) != NULL) {
total -= (long)getslength(p);
free(getstring(p));
}
break;
#ifndef XLISP_ONLY
case ALLOCATED_DATA:
if (getadaddr(p) != NULL) {
total -= getadsize(p); /* cast added JKL */
if (getadreloc(p)) StRFree((StReallocData)getadaddr(p));
else StFree(getadaddr(p));
}
break;
#endif /* XLISP_ONLY */
case STREAM:
if (getfile(p))
osclose(getfile(p));
break;
case SYMBOL:
case OBJECT:
case VECTOR:
case CLOSURE:
case COMPLEX: /* L. Tierney */
case DISPLACED_ARRAY: /*L. Tierney */
case STRUCT:
if (p->n_vsize) {
total -= (long) ((long) p->n_vsize * sizeof(LVAL));/* (long) added - L. Tierney */
free(p->n_vdata);
}
break;
}
p->n_type = FREE;
rplaca(p,NIL);
rplacd(p,fnodes);
fnodes = p;
nfree += 1L;
}
else
p->n_flags &= ~MARK;
}
}
/* addseg - add a segment to the available memory */
LOCAL int addseg()
{
SEGMENT *newseg;
LVAL p;
int n;
/* allocate the new segment */
if (anodes == 0 || (newseg = newsegment(anodes)) == NULL)
return (FALSE);
/* add each new node to the free list */
p = &newseg->sg_nodes[0];
for (n = anodes; --n >= 0; ++p) {
rplacd(p,fnodes);
fnodes = p;
}
/* return successfully */
return (TRUE);
}
/* newsegment - create a new segment (only called here and in xlimage.c) */
SEGMENT *newsegment(n)
int n;
{
SEGMENT *newseg;
#ifdef MACINTOSH /* L. Tierney */
maximum_memory();
#endif MACINTOSH
/* allocate the new segment */
if ((newseg = (SEGMENT *)calloc(1,segsize(n))) == NULL)
return (NULL);
/* initialize the new segment */
newseg->sg_size = n;
newseg->sg_next = NULL;
if (segs)
lastseg->sg_next = newseg;
else
segs = newseg;
lastseg = newseg;
/* update the statistics */
total += (long)segsize(n);
nnodes += (long)n;
nfree += (long)n;
++nsegs;
/* return the new segment */
return (newseg);
}
/* stats - print memory statistics */
LOCAL void stats()
{
sprintf(buf,"Nodes: %ld\n",nnodes); stdputstr(buf);
sprintf(buf,"Free nodes: %ld\n",nfree); stdputstr(buf);
sprintf(buf,"Segments: %d\n",nsegs); stdputstr(buf);
sprintf(buf,"Allocate: %d\n",anodes); stdputstr(buf);
sprintf(buf,"Total: %ld\n",total); stdputstr(buf);
sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
}
/* xgc - xlisp function to force garbage collection */
LVAL xgc()
{
/* make sure there aren't any arguments */
xllastarg();
/* garbage collect */
gc();
/* return nil */
return (NIL);
}
/* xexpand - xlisp function to force memory expansion */
LVAL xexpand()
{
LVAL num;
int n,i;
/* get the new number to allocate */
if (moreargs()) {
num = xlgafixnum();
n = getfixnum(num);
}
else
n = 1;
xllastarg();
/* allocate more segments */
for (i = 0; i < n; i++)
if (!addseg())
break;
/* return the number of segments added */
return (cvfixnum((FIXTYPE)i));
}
/* xalloc - xlisp function to set the number of nodes to allocate */
LVAL xalloc()
{
int n,oldn;
LVAL num;
/* get the new number to allocate */
num = xlgafixnum();
n = getfixnum(num);
/* make sure there aren't any more arguments */
xllastarg();
/* set the new number of nodes to allocate */
oldn = anodes;
anodes = n;
/* return the old number */
return (cvfixnum((FIXTYPE)oldn));
}
/* xmem - xlisp function to print memory statistics */
LVAL xmem()
{
/* allow one argument for compatiblity with common lisp */
if (moreargs()) xlgetarg();
xllastarg();
/* print the statistics */
stats();
/* return nil */
return (NIL);
}
#ifdef SAVERESTORE
/* xsave - save the memory image */
LVAL xsave()
{
unsigned char *name;
/* get the file name, verbose flag and print flag */
name = getstring(xlgetfname());
xllastarg();
/* save the memory image */
return (xlisave(name) ? true : NIL);
}
/* xrestore - restore a saved memory image */
LVAL xrestore()
{
extern jmp_buf top_level;
unsigned char *name;
/* get the file name, verbose flag and print flag */
name = getstring(xlgetfname());
xllastarg();
/* restore the saved memory image */
if (!xlirestore(name))
return (NIL);
/* return directly to the top level */
stdputstr("[ returning to the top level ]\n");
longjmp(top_level,1);
}
#endif /* SAVERESTORE */
/* xlminit - initialize the dynamic memory module */
void xlminit()
{
LVAL p;
int i;
/* initialize our internal variables */
segs = lastseg = NULL;
nnodes = nfree = total = 0L;
nsegs = gccalls = 0;
anodes = NNODES;
fnodes = NIL;
/* allocate the fixnum segment */
if ((fixseg = newsegment(SFIXSIZE)) == NULL)
xlfatal("insufficient memory");
/* initialize the fixnum segment */
p = &fixseg->sg_nodes[0];
for (i = SFIXMIN; i <= SFIXMAX; ++i) {
p->n_type = FIXNUM;
p->n_fixnum = i;
++p;
}
/* allocate the character segment */
if ((charseg = newsegment(CHARSIZE)) == NULL)
xlfatal("insufficient memory");
/* initialize the character segment */
p = &charseg->sg_nodes[0];
for (i = CHARMIN; i <= CHARMAX; ++i) {
p->n_type = CHAR;
p->n_chcode = i;
++p;
}
/* initialize structures that are marked by the collector */
obarray = xlenv = xlfenv = xldenv = NIL;
s_gcflag = s_gchook = NIL;
/* allocate the evaluation stack */
if ((xlstkbase = (LVAL **)malloc(EDEPTH * sizeof(LVAL *))) == NULL)
xlfatal("insufficient memory");
xlstack = xlstktop = xlstkbase + EDEPTH;
/* allocate the argument stack */
if ((xlargstkbase = (LVAL *)malloc(ADEPTH * sizeof(LVAL))) == NULL)
xlfatal("insufficient memory");
xlargstktop = xlargstkbase + ADEPTH;
xlfp = xlsp = xlargstkbase;
*xlsp++ = NIL;
}